#!/local/bin/perl
# PERL subroutine:
# Tell whether something is a legal E-mail address or not
#
# Legality is defined as a triple:
# - Outcome - E_BAD, E_OK, E_TEMP
# - Level at which outcome is checked - L_SYNTAX, L_DNS, L_SMTP, L_MAIL
# - Error message detail.
package IsEmail;
use strict;

require Exporter;
use Net::DNS;
use Net::SMTP;
use Time::HiRes qw(time); # override time() with floating version
use Sys::Hostname;

use vars qw(@ISA @EXPORT_OK $DEBUG $notemailbecause $res %answers $timeout);

@ISA = qw(Exporter);
@EXPORT_OK = qw(isemail $notemailbecause);
$DEBUG = 0;
$timeout = 5; # seconds to time out in SMTP sessions
              # this default is short!
$notemailbecause = ""; # this way is Not Nice (tm)


# constants
sub E_BAD { 0; }
sub E_OK { 1; }
sub E_TEMP { 2; }
sub E_CONTINUE { 3; } # Internal to SMTP routines

sub L_SYNTAX { "SYNTAX"; }
sub L_DNS { "DNS" };
sub L_SMTP { "SMTP" };
sub L_MAIL { "MAIL" };

sub resultname {
    my $r = shift;
    if ($r == E_BAD) { return "BAD"; }
    elsif ($r == E_OK) { return "OK"; }
    elsif ($r == E_TEMP) { return "TEMP"; }
    elsif ($r == E_CONTINUE) { return "CONTINUE"; }
}

# static data
my $res = new Net::DNS::Resolver;

sub checkemail {
    my ($addr, $restrict) = @_;
    my ($localpart, $domain, $ok, $level, $why);
    # just to get over -w..
    $restrict = '' if !defined($restrict);
    $ok = 1;

    if ($addr !~ /^(.+)@(\S+)$/ || $addr =~ /\n$/) {
	# perl insists on skipping the last \n in regexp - so have to check
	# explicitly...
	if ($addr !~ /@/) {
	    $ok = E_BAD;
	    $level = L_SYNTAX;
	    $why = "No @ sign found in address";
	} else {
	    $ok = E_BAD;
	    $level = L_SYNTAX;
	    $why = "Spaces in domain part";
	}
    } else {
        $localpart = $1;
        $domain = $2;
	$DEBUG && warn "Localpart is <$localpart> domain is <$domain>\n";
	if ($localpart =~ /^".*"$/) {
	    # Quoted-string; no further checks (could check for unbalance..)
	} elsif ($localpart =~ /[ ()<>@,;:\\"\[\]]/) { # "
	    $ok = E_BAD;
	    $level = L_SYNTAX;
	    $why = "Illegal character in local part: $&";
	}
	if ($ok && $domain =~ /^\./ || $domain =~ /\.\./ || $domain =~ /\.$/) {
            $ok = E_BAD;
	    $level = L_SYNTAX;
            $why = "Empty label in domain part";
        }
	if ($ok && $restrict ne "nodns") {
	    ($ok, $why) = isdnslisted($domain);
	    $level = L_DNS;
	    if ($ok eq E_OK && $restrict ne "nosmtp") {
		$level = L_SMTP;
		($ok, $why) = issmtpok($addr);
	    }
	}
    } 
    ++ $answers{resultname($ok) . " " . $level . " " . $why};
    return ($ok, $level, $why);
}

#---------- Compatibility routines - stuff used to be called like this ----
sub isemail {
    my ($ok, $level, $why) = checkemail(@_);
    $notemailbecause = $level . ": " . $why;
    return $ok;
}

sub candoemail {
    return isdnslisted(@_);
}

#--------- DNS verification ------------------

sub isdnslisted {
    my $dom = shift;
    my ($anscount, $why, $cname);
    my @result;

    ($anscount, $why, $cname) = ask($dom, "MX");
    if ($anscount == 0) {
	if ($why eq "NOERROR") {
	    # domain probably exists, but no MX
	    ($anscount, $why) = ask($cname, "A");
	    if ($anscount > 0) {
		@result = (E_OK, "A");
	    } else {
		@result = (E_BAD, "No records");
	    }
	} elsif ($why eq "SERVFAIL") {
	    @result = (E_TEMP, "Server failure");
	} elsif ($why eq "timeout" || $why eq "query timed out") {
	    @result = (E_TEMP, $why);
	} elsif ($why eq "NXDOMAIN") {
	    @result = (E_BAD, "No such domain");
	} else {
	    @result = (E_BAD, "DNS error $why");
	}
    } else {
	@result = (E_OK, "MX");
    }
    warn "Strange: Answer with error: $anscount $why\n"
	if $anscount && ($why ne "NOERROR" && $why ne "");
    warn "Strange: NoAnswer with  no error: $anscount $why\n"
	if !$anscount && $why eq "";
    if ($anscount > 0) {
	return @result;
    } elsif ($result[0] == E_OK) {
	return (E_BAD, "Internal error: E_OK with empty DNS query result");
    } else {
	return @result;
    }
}

sub ask {
    my $dom = shift;
    my $type = shift;
    my $level = shift;
    my ($recs, $rr);
    my $anscount;
    my $cname = $dom;
    my $err = "";
    my @answers;
    
    my $starttime = time();
    $DEBUG && warn "Asking $dom for $type\n";
    $recs = $res->query($dom, $type);
    if ($recs) {
	$DEBUG && warn "Got answer\n";
	foreach $rr ($recs->answer) {
	    $DEBUG && warn $rr->string, "\n";
	    if ($rr->type eq "CNAME") {
		$DEBUG && warn "$dom returned CNAME\n";
		$cname = $rr->cname;
		if ($level < 10) {
		    $DEBUG && warn "Recursing to $cname\n";
		    ($anscount, $err, $cname) = 
			ask($cname, $type, $level + 1);
		} else {
		    $err = "CNAME loop";
		}
	    } elsif ($rr->type eq $type) {
		++ $anscount;
		if ($type eq "MX") {
		    $DEBUG && warn "Answer of $type is " .  $rr->exchange . "\n";
		    push(@answers, $rr->exchange);
		}
	    } else {
		$DEBUG && warn "Extra data:", $rr->string, "\n";
	    }
	}
    } else {
	$DEBUG && warn "Failure - ", $res->errorstring, "\n";
	$err = $res->errorstring;
    }
    my $elapsed = sprintf("%5.2f", time() - $starttime);
    warn "Resolving $type $dom took $elapsed seconds\n"
	if $elapsed > 3 && $DEBUG;
    return ($anscount, $err, $cname);
}

#----------------- SMTP VERIFICATION ----------------------

sub issmtpok {

    my $addr = shift;
    my ($result, $why) = issmtpok2($addr);

    if ($why =~ /\Q$addr/) { # no metachars in addr
	$DEBUG && warn "Taking $addr out of $why\n";
	$why =~ s/$addr/@/;
    }
    return ($result, $why);
}

sub issmtpok2 {

    my $addr = shift;
    my ($local, $name) = split(/\@/, $addr);
    my ($ok, $why);
    
    my @mx = mx($res, $name);
    if (@mx) {
	my $rr;
	foreach $rr (sort {$a->preference <=> $b->preference} @mx) { 
	    $DEBUG && print "MX found: ", $rr->preference, " ", $rr->exchange, "\n";
	    my $ipaddr = inet_aton($rr->exchange);
	    if (!$ipaddr) {
		$DEBUG && print "MX with no A: ", $rr->exchange, "\n";
		$why = "MX pointing to no A record";
		next;
	    } else {
		$DEBUG && print "MX ", $rr->exchange, " has IP ", inet_ntoa($ipaddr), "\n";
		($ok, $why) = smtponehost($rr->exchange, $addr);
		if ($ok != E_CONTINUE) { # definite answer
		    return ($ok, $why . " (MX)");
		}
	    }
	}
	return (E_TEMP, "$why (MX EOL)"); # none of the MX fit
    } else { # go for A records - let Net::SMTP do the lookup
	($ok, $why) = smtponehost($name, $addr);
        $ok = E_TEMP if $ok == E_CONTINUE;
        return ($ok, $why);
    }


}
sub smtponehost {
    my ($host, $addr) = @_;
    my ($result, $why, $code);
    # note: inet_aton is not supposed to convert name to address.
    # it does. that's weird.
    my $aton = inet_aton($host);
    if (!$aton) {
	warn "inet_aton of $host returned null\n";
	return (E_BAD, "$host not resolvable");
    }
    my $ipaddr = inet_ntoa($aton);
    if ($ipaddr eq '127.0.0.1') {
	return (E_BAD, "Address is at localhost (127.0.0.1)");
    }
    $DEBUG && warn "Contacting $host ($ipaddr) about $addr\n";
    my $s = smtpconnect($ipaddr, $timeout);
    if (!$s) {
	$result = E_CONTINUE; # for MX handling
	return ($result, $@);
    } else {
	$s->mail("tester\@counter.li.org") || return smtperror($s, "MAIL");
	if (!$s->to($addr)) {
	    my @res = reciperror($s);
	    $s->reset(); # we don't care whether this fails
	    $s->quit();  # we just want to clean up
	    return @res;
	}
	$code = $s->code();
	$s->reset() || return smtperror($s, "RSET");
	$s->quit() || return smtperror($s, "QUIT");
	$s = undef;
	return (E_OK, "Code $code");
    }
}

sub smtpconnect {

    use POSIX ':signal_h';
    use Socket;
    
    my $host = shift;
    my $timeout = shift;
    my $s;
    my $error;
    my $start = time();
    # this zany-sounding stuff is because timeout in connect() on
    # Linux simply does NOT WORK.
    eval {
	local $SIG{'ALRM'} = sub { 
	    die "timed-out\n";
	};
	alarm $timeout;
	$DEBUG && warn "Connecting to $host (raw socket)\n";
	socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
	my $paddr = sockaddr_in(25, inet_aton($host));
	connect(SOCK, $paddr) || die "failed: $!\n";
	close SOCK;
    };
    alarm(0); # must be outside eval in case die()d out of it and not from ALRM
    $DEBUG && warn "After eval: $@\n";
    if ($@ =~ /^timed-out/) { # returned is with \n, so match
        $DEBUG && warn "SMTP Connect: Timeout after ", int(time() - $start), " seconds\n";
	$@ = "Connect: Timeout after " . int(time() - $start + 0.5) . " seconds";
	return undef;
    } elsif ($@) {
	chop $@;
	$@ = "Connect(raw) " . $@;
	return undef;
    } else {
	my $hostname = hostname();
	$DEBUG && warn "Connecting to $host with timeout $timeout\n";
	$s = Net::SMTP->new($host, "Timeout" => $timeout, "Hello" => $hostname);
	$DEBUG && warn "Connect took ", time() - $start, " seconds\n";
	if (!$s && !$@) {
	    # guess that this is it:
	    $@ = "Timeout in greet/HELO - $timeout seconds";
	} elsif (!$s) {
	    $@ = "Connect(2): Failure $@";
	}
	return $s;
    }
}

sub smtperror {
    my $s = shift;
    my $verb = shift;
    my $err = $s->message();
    chop $err;
    if ($s->code() == 0 && !$err) {
	return (E_TEMP, "Timeout in $verb - $timeout seconds");
    } else {
	return (E_TEMP, "Error in $verb: "
		.  $s->code() . " " . $err);
    }
}

# code recipient error
sub reciperror {
    my $s = shift;

    if ($s->code() =~ /^5/) {
	# some error texts ought not to give this...
	my $err = $s->message();
	chop $err;
	if ($s->code() == 550 && $err =~ /We do not relay|relaying denied|relaying to/i) {
	    # DNS-listed domain handler not relaying -> misconfig
	    return (E_TEMP, "RELAY problem: "
		    .  $s->code() . " " . $err);
	} elsif ($s->code() == 550 && $err =~ /User unknown|unknown user|unknown local user|no such user|unknown local part|no mailbox for this user/i) {
	    return (E_BAD, $s->code() . " user unknown");
	} elsif ($s->code() == 571) { # Mostly relay configs
	    return (E_TEMP, "RELAY problem: " . $s->code() . " " . $err);
	} elsif ($s->code() == 552) { # Mailbox full, storage limit exceeded
	    return (E_TEMP, "Mailbox full: " . $s->code() . " " . $err);
	} elsif ($s->code() == 554) {
	    # Transaction failed - a variety of reasons
	    if ($err =~ / Relay access denied/) {
		return (E_TEMP, "RELAY problem: " . $s->code() . " " . $err);
	    } else {
		return (E_BAD, "Error in RCPT TO: "
			.  $s->code() . " " . $err);
	    }
	} else {
	    return (E_BAD, "Error in RCPT TO: "
		    .  $s->code() . " " . $err);
	}
    } else {
	return smtperror($s, "TO");
    }
}

1;
